;; codegen.scm: code generation API for r6rs-thrift
;; Copyright (C) 2012 Julian Graham

;; r6rs-thrift is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

#!r6rs

(library (thrift compile codegen)
  (export thriftc:default-naming-context
          
          thriftc:make-naming-context
	  thriftc:naming-context?
	  thriftc:naming-context-enum-naming-context
	  thriftc:naming-context-exception-naming-context
	  
	  thriftc:generate-thrift
	  thriftc:generate-struct
	  thriftc:generate-struct-builder
	  thriftc:generate-service
	  thriftc:generate-enum
	  thriftc:generate-const
	  thriftc:generate-type-registration
	  thriftc:generate-typedef)
  (import (rnrs)
	  (thrift compile parse)
	  (thrift compile resolve)
	  (thrift compile type)
	  (thrift private)
	  (srfi :13)
	  (srfi :14))

  (define-record-type (thriftc:enum-naming-context
		       thriftc:make-enum-naming-context
		       thriftc:enum-naming-context?)
    (fields type-name constructor-name predicate-name value-name))

  (define-record-type (thriftc:struct-builder-naming-context
		       thriftc:make-struct-builder-naming-context
		       thriftc:struct-builder-naming-context?)
    (fields type-name
	    constructor-name
	    predicate-name

	    field-accessor-name
	    field-mutator-name
	    field-clear-name
	    field-has-name

	    build-name))

  (define-record-type (thriftc:struct-naming-context
		       thriftc:make-struct-naming-context
		       thriftc:struct-naming-context?)
    (fields type-name
	    predicate-name

	    field-accessor-name 
	    field-has-name

	    writer-name
	    reader-name))

  (define-record-type (thriftc:exception-builder-naming-context
		       thriftc:make-exception-builder-naming-context
		       thriftc:exception-builder-naming-context?)
    (fields type-name
	    constructor-name
	    predicate-name

	    field-accessor-name 
	    field-mutator-name
	    field-clear-name
	    field-has-name
	    
	    build-name))

  (define-record-type (thriftc:exception-naming-context
		       thriftc:make-exception-naming-context
		       thriftc:exception-naming-context?)
    (fields type-name
	    predicate-name

	    field-accessor-name 
	    field-has-name

	    writer-name
	    reader-name))

  (define-record-type (thriftc:const-naming-context
		       thriftc:make-const-naming-context
		       thriftc:const-naming-context?)
    (fields const-name))

  (define-record-type (thriftc:service-naming-context
		       thriftc:make-service-naming-context
		       thriftc:service-naming-context?)
    (fields type-name constructor-name predicate-name function-accessor-name))

  (define-record-type (thriftc:naming-context
		       thriftc:make-naming-context
		       thriftc:naming-context?)
    (fields library-name

	    const-naming-context
	    enum-naming-context
	    
	    exception-builder-naming-context
	    exception-naming-context

	    service-naming-context

	    struct-builder-naming-context
	    struct-naming-context))

  (define default-namespace "thrift.default")

  (define (gensym-values . vars) 
    (apply values (syntax->datum (generate-temporaries vars))))

  (define (thriftc:default-namespace-name-transformer namespace)
    (map string->symbol 
	 (string-tokenize namespace (char-set-complement (char-set #\.)))))

  (define thriftc:default-const-naming-context
    (thriftc:make-const-naming-context
     (lambda (const) (string->symbol (thriftc:const-definition-name const)))))

  (define thriftc:default-enum-naming-context    
    (thriftc:make-enum-naming-context
     (lambda (enum) (string->symbol (thriftc:enum-definition-name enum)))
     (lambda (enum)
       (string->symbol 
	(string-append "make-" (thriftc:enum-definition-name enum))))
     (lambda (enum)
       (string->symbol 
	(string-append (thriftc:enum-definition-name enum) "?")))
     (lambda (enum value)
       (string->symbol
	(string-append (thriftc:enum-definition-name enum) "-" 
		       (thriftc:enum-value-definition-name value))))))

  (define (default-struct-builder-name struct)
    (string-append (thriftc:struct-definition-name struct) "-builder"))
  
  (define thriftc:default-struct-builder-naming-context 

    (thriftc:make-struct-builder-naming-context 
     (lambda (struct) (string->symbol (default-struct-builder-name struct)))
     (lambda (struct) 
       (string->symbol 
	(string-append "make-" (default-struct-builder-name struct))))
     (lambda (struct) 
       (string->symbol 
	(string-append (default-struct-builder-name struct) "?")))

     (lambda (struct field) 
       (string->symbol
	(string-append (default-struct-builder-name struct) "-"
		       (thriftc:field-definition-name field))))
     (lambda (struct field)
       (string->symbol 
	(string-append "set-" (default-struct-builder-name struct) "-"
		       (thriftc:field-definition-name field) "!")))
     (lambda (struct field)
       (string->symbol 
	(string-append "clear-" (default-struct-builder-name struct) "-"
		       (thriftc:field-definition-name field) "!")))
     (lambda (struct field)
       (string->symbol
	(string-append "has-" (default-struct-builder-name struct) "-"
		       (thriftc:field-definition-name field) "?")))

     (lambda (struct)
       (string->symbol
	(string-append (default-struct-builder-name struct) "-build")))))

  (define thriftc:default-struct-naming-context 
    (thriftc:make-struct-naming-context 
     (lambda (struct) (string->symbol (thriftc:struct-definition-name struct)))
     (lambda (struct) 
       (string->symbol 
	(string-append (thriftc:struct-definition-name struct) "?")))
     (lambda (struct field) 
       (string->symbol
	(string-append (thriftc:struct-definition-name struct) "-"
		       (thriftc:field-definition-name field))))
     (lambda (struct field)
       (string->symbol
	(string-append "has-" (thriftc:struct-definition-name struct) "-"
		       (thriftc:field-definition-name field) "?")))

     (lambda (struct)
       (string->symbol 
	(string-append (thriftc:struct-definition-name struct) "-write")))
     (lambda (struct)
       (string->symbol
	(string-append (thriftc:struct-definition-name struct) "-read")))))

  (define thriftc:default-service-naming-context 
    (thriftc:make-service-naming-context 
     (lambda (service)
       (string->symbol (thriftc:service-definition-name service)))
     (lambda (service)
       (string->symbol
	(string-append "make-" (thriftc:service-definition-name service))))
     (lambda (service)
       (string->symbol
	(string-append (thriftc:service-definition-name service) "?")))

     (lambda (service function)
       (string->symbol
	(string-append (thriftc:service-definition-name service) "-" 
		       (thriftc:function-definition-name function))))))

  (define thriftc:default-exception-builder-naming-context 
    (thriftc:make-exception-builder-naming-context 
     (lambda (exception) 
       (string->symbol (thriftc:struct-definition-name exception)))
     (lambda (exception)
       (string->symbol 
	(string-append "make-" (thriftc:struct-definition-name exception))))
     (lambda (exception)
       (string->symbol 
	(string-append (thriftc:struct-definition-name exception) "?")))

     (lambda (exception field) 
       (string->symbol
	(string-append (thriftc:struct-definition-name exception) "-"
		       (thriftc:field-definition-name field))))
     (lambda (exception field)
       (string->symbol 
	(string-append "set-" (thriftc:struct-definition-name exception) "-"
		       (thriftc:field-definition-name field) "!")))
     (lambda (exception field)
       (string->symbol
	(string-append "clear-" (thriftc:struct-definition-name exception) 
		       "-" (thriftc:field-definition-name field) "!")))
     (lambda (exception field)
       (string->symbol
	(string-append "has-" (thriftc:struct-definition-name exception) "-"
		       (thriftc:field-definition-name field) "?")))

     (lambda (exception)
       (string->symbol
	(string-append (thriftc:struct-definition-name exception) "-build")))))

  (define (type-reference->type-reference-expr reference)
    (if (thrift:complex-type-reference? reference)
	`(thrift:make-complex-type-reference
	  ,(thrift:type-reference-name reference)
	  ,(thrift:type-reference-location reference)
	  #f
	  ,@(map type-reference->type-reference-expr
		 (thrift:complex-type-reference-parameters reference)))
       
	`(thrift:make-type-reference 
	  ,(thrift:type-reference-name reference)
	  ,(thrift:type-reference-location reference)
	  #f)))

  (define (type-descriptor->type-reference-expr descriptor)
    (if (thrift:parameterized-field-type-descriptor? descriptor)
	`(thrift:make-complex-type-reference
	  ,(thrift:field-type-descriptor-name descriptor)
	  ,(thrift:field-type-descriptor-location descriptor)
	  #f
	  ,@(map type-reference->type-reference-expr
		 (thrift:parameterized-field-type-descriptor-parameters 
		  descriptor)))

	`(thrift:make-type-reference 
	  ,(thrift:field-type-descriptor-name descriptor)
	  ,(thrift:field-type-descriptor-location descriptor)
	  #f)))

  (define thriftc:default-exception-naming-context
    (thriftc:make-exception-naming-context
     (lambda (exception) 
       (string->symbol 
	(string-append "&" (thriftc:struct-definition-name exception))))
     (lambda (exception)
       (string->symbol 
	(string-append (thriftc:struct-definition-name exception) "?")))

     (lambda (exception field) 
       (string->symbol
	(string-append (thriftc:struct-definition-name exception) "-"
		       (thriftc:field-definition-name field))))
     (lambda (exception field)
       (string->symbol
	(string-append "has-" (thriftc:struct-definition-name exception) "-"
		       (thriftc:field-definition-name field) "?")))

     (lambda (exception)
       (string->symbol 
	(string-append (thriftc:struct-definition-name exception) "-write")))
     (lambda (exception)
       (string->symbol 
	(string-append (thriftc:struct-definition-name exception) "-read")))))

  (define thriftc:default-naming-context
    (thriftc:make-naming-context 
     
     thriftc:default-namespace-name-transformer 

     thriftc:default-const-naming-context
     thriftc:default-enum-naming-context
     thriftc:default-exception-builder-naming-context
     thriftc:default-exception-naming-context
     thriftc:default-service-naming-context 
     thriftc:default-struct-builder-naming-context
     thriftc:default-struct-naming-context))

  (define default-imports
    '((rnrs base) 
      (rnrs enums) 
      (rnrs hashtables) 
      (rnrs records procedural) 
      (rnrs records syntactic) 
      (thrift private)
      (thrift protocol)))

  (define (thriftc:generate-type-registration 
	   definition namespace naming-context)

    (define exception-naming-context 
      (thriftc:naming-context-exception-naming-context naming-context))
    (define struct-naming-context 
      (thriftc:naming-context-struct-naming-context naming-context))
    
    (define exception-name 
      (thriftc:exception-naming-context-type-name exception-naming-context))
    (define struct-name 
      (thriftc:struct-naming-context-type-name struct-naming-context))
	    
    (define (register-enum definition)
      (let ((name (thriftc:enum-definition-name definition)))
	`((thrift:register-type!
	   (thrift:make-enum-field-type-descriptor 
	    ,name 
	    ,namespace
	    ,(thriftc:enum-definition-default definition)
	    (list ,@(map (lambda (value-definition)
			   `(thrift:make-enum-value-descriptor
			     ,(thriftc:enum-value-definition-name
			       value-definition)
			     ,(thriftc:enum-value-definition-ordinal
			       value-definition)))
			 (thriftc:enum-definition-values definition))))))))
    
    (define (register-struct definition)
      (let ((name (thriftc:struct-definition-name definition))
	    (fields (map (lambda (field)
			   `(thrift:make-field-descriptor
			     ,(thriftc:field-definition-ordinal field)
			     ,(thriftc:field-definition-name field)
			     ,(type-descriptor->type-reference-expr
			       (thrift:type-reference-descriptor
				(thriftc:field-definition-type field)))
			     ,(thriftc:field-definition-required? field)
			     #f))
			 (thriftc:struct-definition-fields definition))))

	`((thrift:register-type!
	   (thrift:make-struct-field-type-descriptor
	    ,name
	    ,namespace
	    ,(if (thriftc:struct-definition-exception? definition)
		 (exception-name definition)
		 (struct-name definition))
	    (list ,@fields)
	    ,(thriftc:struct-definition-exception? definition)
	    ,(thriftc:struct-definition-union? definition))))))

    (cond ((thriftc:enum-definition? definition) (register-enum definition))
	  ((thriftc:struct-definition? definition)
	   (register-struct definition))
	  (else (raise (make-assertion-violation)))))

  (define (thriftc:generate-thrift thrift naming-context)
    (define const-naming-context
      (thriftc:naming-context-const-naming-context naming-context))
    (define enum-naming-context
      (thriftc:naming-context-enum-naming-context naming-context))
    (define exception-naming-context
      (thriftc:naming-context-exception-naming-context naming-context))
    (define service-naming-context
      (thriftc:naming-context-service-naming-context naming-context))
    (define struct-naming-context
      (thriftc:naming-context-struct-naming-context naming-context))

    (define namespace (thriftc:derive-namespace thrift))

    (define library-name
      ((thriftc:naming-context-library-name naming-context) namespace))

    (define (register-types definitions)
      (define (register-types-inner definitions names output)
	
	(define (field-definition->type-descriptor field-definition)
	  (thrift:type-reference-descriptor
	   (thriftc:field-definition-type field-definition)))
	
	(define (register-enum definition)
	  (let ((name (thriftc:enum-definition-name definition)))
	    (if (not (hashtable-contains? names name))
		(begin (hashtable-set! names name name)
		       (register-types-inner
			(cdr definitions)
			names
			(append (thriftc:generate-type-registration 
				 definition namespace naming-context) 
				output)))
		(register-types-inner (cdr definitions) names output))))
	
	(define (register-struct definition)
	  (let ((name (thriftc:struct-definition-name definition)))
	    (if (not (hashtable-contains? names name))		
		(begin (hashtable-set! names name name)
		       (register-types-inner
			(cdr definitions) 
			names 
			(append (thriftc:generate-type-registration 
				 definition namespace naming-context) 
				output)))
		(register-types-inner (cdr definitions) names output))))

	(if (not (null? definitions))
	    (let ((definition (car definitions)))
	      (cond ((thriftc:enum-definition? definition)
		     (register-enum definition))
		    ((thriftc:struct-definition? definition)
		     (register-struct definition))
		    (else (register-types-inner 
			   (cdr definitions) names output))))
	    (reverse output)))

      (register-types-inner 
       definitions (make-hashtable string-hash equal?) '()))
    
    (define (generate-definition definition)
      (cond ((thriftc:const-definition? definition)
	     (thriftc:generate-const definition naming-context))
	    ((thriftc:enum-definition? definition)
	     (thriftc:generate-enum definition naming-context))
	    ((thriftc:service-definition? definition)
	     (thriftc:generate-service namespace definition naming-context))
	    ((thriftc:struct-definition? definition)
	     (append
	      (thriftc:generate-struct definition naming-context)
	      (thriftc:generate-struct-builder 
	       definition namespace naming-context)))
	    (else '())))

    (thriftc:resolve thrift)

    `(library ,library-name
       (export ,@(thriftc:thrift-exports thrift naming-context))
       (import 
	,@(append default-imports
		  (map (lambda (p) 
			 ((thriftc:naming-context-library-name 
			   naming-context)
			  (or (thriftc:namespace-name p) 
			      default-namespace)))
		       (thriftc:thrift-includes thrift))))
       
       ,@(let loop ((definitions (thriftc:thrift-definitions thrift))
		    (output '()))
	   (if (or (not definitions) (null? definitions))
	       (reverse output)
	       (let ((definition (car definitions)))
		 (loop (cdr definitions) 
		       (append (generate-definition definition) 
			       output)))))

       ,@(register-types (thriftc:thrift-definitions thrift))))
  
  (define (thriftc:const-exports const const-naming-context)
    (list ((thriftc:const-naming-context-const-name const-naming-context) 
	   const)))

  (define (thriftc:enum-exports enum enum-naming-context)
    (list ((thriftc:enum-naming-context-type-name enum-naming-context) enum)
	  ((thriftc:enum-naming-context-predicate-name enum-naming-context) 
	   enum)
	  ((thriftc:enum-naming-context-constructor-name enum-naming-context)
	   enum)))

  (define (thriftc:exception-builder-exports 
	   exception exception-builder-naming-context)
    (define mutator-name 
      (thriftc:exception-builder-naming-context-field-mutator-name 
       exception-builder-naming-context))
    (define accessor-name 
      (thriftc:exception-builder-naming-context-field-accessor-name 
       exception-builder-naming-context))
    (define clear-name 
      (thriftc:exception-builder-naming-context-field-clear-name 
       exception-builder-naming-context))
    (define has-name 
      (thriftc:exception-builder-naming-context-field-has-name 
       exception-builder-naming-context))

    (append (list ((thriftc:exception-builder-naming-context-constructor-name
                    exception-builder-naming-context) exception)
                  ((thriftc:exception-builder-naming-context-predicate-name
                    exception-builder-naming-context) exception)
                  ((thriftc:exception-builder-naming-context-build-name
                    exception-builder-naming-context) exception))

	    (let loop ((fields (thriftc:struct-definition-fields exception))
		       (bindings (list)))
	      (if (null? fields)
		  (reverse bindings)
		  (let ((f (car fields)))
		    (loop (cdr fields)
			  (cons (accessor-name exception f)
				(if (not 
				     (thriftc:field-definition-required? f))
				    (cons (has-name exception f) bindings)
				    bindings))))))))

  (define (thriftc:exception-exports exception exception-naming-context)
    (define accessor-name 
      (thriftc:exception-naming-context-field-accessor-name 
       exception-naming-context))
    (define has-name (thriftc:exception-naming-context-field-has-name 
		      exception-naming-context))

    (append (list ((thriftc:exception-naming-context-predicate-name 
		    exception-naming-context) exception)
		  ((thriftc:exception-naming-context-writer-name
		    exception-naming-context) exception)
		  ((thriftc:exception-naming-context-reader-name
		    exception-naming-context) exception))

	    (let loop ((fields (thriftc:struct-definition-fields exception))
		       (bindings (list)))
	      (if (null? fields)
		  (reverse bindings)
		  (let ((f (car fields)))
		    (loop (cdr fields)
			  (cons (accessor-name exception f)
				(if (not 
				     (thriftc:field-definition-required? f))
				    (cons (has-name exception f) bindings)
				    bindings))))))))

  (define (thriftc:service-exports service naming-context)
    (define service-naming-context
      (thriftc:naming-context-service-naming-context naming-context))
    (define function-accessor-name 
      (thriftc:service-naming-context-function-accessor-name 
       service-naming-context))

    (append 
     (list ((thriftc:service-naming-context-constructor-name
	     service-naming-context) service)
	   ((thriftc:service-naming-context-predicate-name
	     service-naming-context) service))
                  
     (map (lambda (function) (function-accessor-name service function)) 
	  (thriftc:service-definition-functions service))))

  (define (thriftc:struct-builder-exports struct struct-builder-naming-context)
    (define mutator-name 
      (thriftc:struct-builder-naming-context-field-mutator-name 
       struct-builder-naming-context))
    (define accessor-name 
      (thriftc:struct-builder-naming-context-field-accessor-name 
       struct-builder-naming-context))
    (define clear-name (thriftc:struct-builder-naming-context-field-clear-name 
			struct-builder-naming-context))
    (define has-name (thriftc:struct-builder-naming-context-field-has-name 
		      struct-builder-naming-context))

    (append (list ((thriftc:struct-builder-naming-context-constructor-name
                    struct-builder-naming-context) struct)
                  ((thriftc:struct-builder-naming-context-predicate-name
                    struct-builder-naming-context) struct)
                  ((thriftc:struct-builder-naming-context-build-name
                    struct-builder-naming-context) struct))

	    (let loop ((fields (thriftc:struct-definition-fields struct))
		       (bindings (list)))
	      (if (null? fields)
		  (reverse bindings)
		  (let ((f (car fields)))
		    (loop (cdr fields)
			  (append (list (mutator-name struct f)
					(accessor-name struct f)
					(clear-name struct f)
					(has-name struct f))
				  bindings)))))))
  
  (define (thriftc:struct-exports struct struct-naming-context)
    (define accessor-name (thriftc:struct-naming-context-field-accessor-name 
			   struct-naming-context))
    (define has-name (thriftc:struct-naming-context-field-has-name 
		      struct-naming-context))

    (append (list ((thriftc:struct-naming-context-predicate-name 
		    struct-naming-context) struct)
		  ((thriftc:struct-naming-context-writer-name
		    struct-naming-context) struct)
		  ((thriftc:struct-naming-context-reader-name
		    struct-naming-context) struct))

	    (let loop ((fields (thriftc:struct-definition-fields struct))
		       (bindings (list)))
	      (if (null? fields)
		  (reverse bindings)
		  (let ((f (car fields)))
		    (loop (cdr fields)
			  (cons (accessor-name struct f)
				(if (not 
				     (thriftc:field-definition-required? f))
				    (cons (has-name struct f) bindings)
				    bindings))))))))

  (define (thriftc:thrift-exports thrift naming-context)
    (define const-naming-context
      (thriftc:naming-context-const-naming-context naming-context))
    (define enum-naming-context
      (thriftc:naming-context-enum-naming-context naming-context))
    (define exception-builder-naming-context
      (thriftc:naming-context-exception-builder-naming-context naming-context))
    (define exception-naming-context
      (thriftc:naming-context-exception-naming-context naming-context))
    (define service-naming-context
      (thriftc:naming-context-service-naming-context naming-context))
    (define struct-builder-naming-context 
      (thriftc:naming-context-struct-builder-naming-context naming-context))
    (define struct-naming-context 
      (thriftc:naming-context-struct-naming-context naming-context))

    (define (generate-export definition)
      (cond ((thriftc:const-definition? definition)
	     (thriftc:const-exports definition const-naming-context))
	    ((thriftc:enum-definition? definition)
	     (thriftc:enum-exports definition enum-naming-context))
	    ((thriftc:service-definition? definition)
	     (thriftc:service-exports definition naming-context))
	    ((thriftc:struct-definition? definition)
	     (if (thriftc:struct-definition-exception? definition)
		 (append 
		  (thriftc:exception-exports 
		   definition exception-naming-context)
		  (thriftc:exception-builder-exports
		   definition exception-builder-naming-context))
		 (append
		  (thriftc:struct-exports definition struct-naming-context)
		  (thriftc:struct-builder-exports 
		   definition struct-builder-naming-context))))
	    (else '())))

    (let loop ((definitions (thriftc:thrift-definitions thrift))
	       (output '()))
      (if (or (not definitions) (null? definitions))
	  (reverse output)
	  (let ((definition (car definitions)))
	    (loop (cdr definitions)
		  (append output (generate-export definition)))))))

  (define (thriftc:generate-const-value type value naming-context)
    (define type-name (thrift:field-type-descriptor-name type))

    (define (generate-const-map)
      (let-values (((ht0) (gensym-values 'ht0)))
	(let* ((params 
		(thrift:parameterized-field-type-descriptor-parameters type))
	       (ktype (thrift:type-reference-descriptor (car params)))
	       (vtype (thrift:type-reference-descriptor (cadr params))))
	  `(let ((,ht0 (make-hashtable
			(thrift:type->hash-function
			 ,(type-descriptor->type-reference-expr ktype))
			(thrift:type->equivalence-function
			 ,(type-descriptor->type-reference-expr ktype)))))
	     ,@(map 
		(lambda (k)
		  (let ((v (hashtable-ref value k #f)))
		    `(hashtable-set! 
		      ,ht0 
		      ,(thriftc:generate-const-value ktype k naming-context)
		      ,(thriftc:generate-const-value vtype v naming-context))))
		(vector->list (hashtable-keys value)))
	     ,ht0))))

    (if (thrift:parameterized-field-type-descriptor? type)
	(cond ((equal? type-name "list") 
	       (let* ((params 
		       (thrift:parameterized-field-type-descriptor-parameters 
			type))
		      (ltype (car params)))
		 `#(,@(map (lambda (elt)
			     (thriftc:generate-const-value 
			      ltype elt naming-context))
			   (vector->list value)))))
	      
	      ((equal? type-name "map") (generate-const-map))
	      ((equal? type-name "set") #f)
	      (else (raise (make-assertion-violation))))
    
	(cond 
	 ((memq type (list thrift:field-type-bool
			   thrift:field-type-byte
			   thrift:field-type-double
			   thrift:field-type-i16
			   thrift:field-type-i32 
			   thrift:field-type-i64
			   thrift:field-type-string))
	  value)
	 ((eq? type thrift:field-type-binary)
	  `(u8-list->bytevector (list ,@(bytevector->u8-list value))))
	 ((thrift:enum-field-type-descriptor? type) #f)
	 ((thrift:struct-field-type-descriptor? type)
	  (cond ((thrift:struct-field-type-descriptor-exception? type) #f)
		((thrift:struct-field-type-descriptor-union? type) #f)
		(else #f)))
	 (else (raise (make-assertion-violation))))))

  (define (thriftc:generate-const const naming-context)
    (define const-naming-context 
      (thriftc:naming-context-const-naming-context naming-context))
    (define const-name 
      ((thriftc:const-naming-context-const-name const-naming-context) const))
    
    `((define ,const-name ,(thriftc:generate-const-value
			    (thrift:type-reference-descriptor
			     (thriftc:const-definition-type const))
			    (thriftc:const-definition-value const)
			    naming-context))))

  (define (thriftc:generate-enum enum naming-context)
    (define enum-naming-context 
      (thriftc:naming-context-enum-naming-context naming-context))

    (define enum-predicate-name 
      (thriftc:enum-naming-context-predicate-name enum-naming-context))
    (define enum-type-name 
      (thriftc:enum-naming-context-type-name enum-naming-context))
    (define enum-constructor-name
      (thriftc:enum-naming-context-constructor-name enum-naming-context))
    (define enum-value-name
      (thriftc:enum-naming-context-value-name enum-naming-context))

    (let-values (((e0 e1) (gensym-values 'e0 'e1)))	  
      (let ((values (map (lambda (value) (enum-value-name enum value))
			 (thriftc:enum-definition-values enum))))
	`((define-enumeration ,(enum-type-name enum) 
	    ,values ,(enum-constructor-name enum))
	  
	  (define ,e1 (make-enumeration ,(list 'quote values)))
	  (define (,(enum-predicate-name enum) ,e0)	   
	    (enum-set-member? ,e0 ,e1))))))

  (define (thriftc:generate-struct struct naming-context)
    (define exception-naming-context 
      (thriftc:naming-context-exception-naming-context naming-context))
    (define struct-naming-context 
      (thriftc:naming-context-struct-naming-context naming-context))

    (define exception? (thriftc:struct-definition-exception? struct))

    (define struct-type-name
      (if exception?
	  (thriftc:exception-naming-context-type-name exception-naming-context)
	  (thriftc:struct-naming-context-type-name struct-naming-context)))

    (define field-accessor-name
      (if exception?
	  (thriftc:exception-naming-context-field-accessor-name
	   exception-naming-context)
	  (thriftc:struct-naming-context-field-accessor-name 
	   struct-naming-context)))
      
    (define field-has-name
      (if exception?
	  (thriftc:exception-naming-context-field-has-name 
	   exception-naming-context)
	  (thriftc:struct-naming-context-field-has-name 
	   struct-naming-context)))

    (define struct-writer-name
      (if exception?
	  (thriftc:exception-naming-context-writer-name 
	   exception-naming-context)
	  (thriftc:struct-naming-context-writer-name struct-naming-context)))

    (define struct-reader-name
      (if exception?
	  (thriftc:exception-naming-context-reader-name 
	   exception-naming-context)
	  (thriftc:struct-naming-context-reader-name struct-naming-context)))

    (define (generate-field-has-predicate struct field)
      (let-values (((s0) (gensym-values 's0)))
	`(define (,(field-has-name struct field) ,s0)
	   (thrift:field-has-value?
	    (thrift:struct-field 
	     ,s0 ,(thriftc:field-definition-ordinal field))))))

    (let-values (((e0 e1 w0 w1 r0) (gensym-values 'e0 'e1 'w0 'w1 'r0)))
      `((define-record-type ,(struct-type-name struct)
	  (fields ,@(let ((fields (thriftc:struct-definition-fields struct)))
		      (if fields
			  (map (lambda (field) 
				 (list 'immutable
				       (string->symbol
					(thriftc:field-definition-name field))
				       (field-accessor-name struct field)))
			       fields)
			  '())))
	  (opaque #t)
	  (parent ,(if exception? '&thrift:condition 'thrift:struct))
	  (sealed #t))

	,@(let loop ((fields (thriftc:struct-definition-fields struct))
		     (bindings (list)))
	    (if (null? fields)
		(reverse bindings)
		(let ((f (car fields)))
		  (if (not (thriftc:field-definition-required? f))
		      (loop (cdr fields)
			    (cons (generate-field-has-predicate struct f) 
				  bindings))
		      (loop (cdr fields) bindings)))))
	
	(define (,(struct-writer-name struct) ,w0 ,w1)
	  (thrift:struct-write ,w0 ,w1))
	(define (,(struct-reader-name struct) ,r0)
	  (thrift:struct-read ,r0)))))

  (define (thriftc:generate-struct-builder struct namespace naming-context)
    (define enum-naming-context
      (thriftc:naming-context-enum-naming-context naming-context))
    (define struct-naming-context 
      (thriftc:naming-context-struct-naming-context naming-context))
    (define struct-builder-naming-context 
      (thriftc:naming-context-struct-builder-naming-context naming-context))

    (define struct-type-name
      (thriftc:struct-naming-context-type-name struct-naming-context))
    (define struct-predicate-name
      (thriftc:struct-naming-context-predicate-name struct-naming-context))

    (define builder-type-name
      (thriftc:struct-builder-naming-context-type-name 
       struct-builder-naming-context))
    (define builder-constructor-name
      (thriftc:struct-builder-naming-context-constructor-name 
       struct-builder-naming-context))
    (define builder-predicate-name
      (thriftc:struct-builder-naming-context-predicate-name 
       struct-builder-naming-context))
    (define builder-build-name
      (thriftc:struct-builder-naming-context-build-name 
       struct-builder-naming-context))

    (define field-accessor-name
      (thriftc:struct-builder-naming-context-field-accessor-name 
       struct-builder-naming-context))
    (define field-mutator-name
      (thriftc:struct-builder-naming-context-field-mutator-name 
       struct-builder-naming-context))
    (define field-has-name
      (thriftc:struct-builder-naming-context-field-has-name 
       struct-builder-naming-context))
    (define field-clear-name
      (thriftc:struct-builder-naming-context-field-clear-name 
       struct-builder-naming-context))

    (define field-internal-mutators
      (make-hashtable (lambda (f) (thriftc:field-definition-ordinal f))
		      (lambda (f1 f2)
			(eqv? (thriftc:field-definition-ordinal f1)
			      (thriftc:field-definition-ordinal f2)))))

    (define (generate-field-clear struct field)
      (let-values (((b0) (gensym-values 'b0)))
	`(define (,(field-clear-name struct field) ,b0)
	   (thrift:clear-field! 
	    (thrift:struct-builder-field
	     ,b0 ,(thriftc:field-definition-ordinal field)))
	   (,(hashtable-ref field-internal-mutators field #f) ,b0 
	    ,(calc-field-default field naming-context)))))

    (define (generate-field-has-predicate struct field)
      (let-values (((b0) (gensym-values 'b0)))
	`(define (,(field-has-name struct field) ,b0)
	   (thrift:field-has-value?
	    (thrift:struct-builder-field 
	     ,b0 ,(thriftc:field-definition-ordinal field))))))

    (define (generate-field-mutator struct field)
      (let-values (((b0 b1) (gensym-values 'b0 'b1)))
	`(define (,(field-mutator-name struct field) ,b0 ,b1)
	   (thrift:set-field-value!
	    (thrift:struct-builder-field
	     ,b0 ,(thriftc:field-definition-ordinal field)) ,b1)
	   (,(hashtable-ref field-internal-mutators field #f) ,b0 ,b1))))
    
    (define (generate-field-descriptor field)
      `(thrift:make-field-descriptor
	,(thriftc:field-definition-ordinal field)
	,(thriftc:field-definition-name field)
	,(type-descriptor->type-reference-expr
	  (thrift:type-reference-descriptor
	   (thriftc:field-definition-type field)))
	,(thriftc:field-definition-required? field)
	,(calc-field-default field naming-context)))
    
    (let-values (((b0 b1 b2 b3) (gensym-values 'b0 'b1 'b2 'b3)))
      (let ((fields (thriftc:struct-definition-fields struct)))
	`((define-record-type (,(builder-type-name struct)
			       ,(builder-constructor-name struct)
			       ,(builder-predicate-name struct))
	    (fields
	     ,@(map (lambda (field)
		      (let-values (((m0) (gensym-values 'm0)))
			(hashtable-set! field-internal-mutators field m0)
			(let ((name (thriftc:field-definition-name field)))
			  (list 'mutable
				(string->symbol name)
				(field-accessor-name struct field)
				m0))))
		    fields))
	    (parent thrift:struct-builder)
	    (protocol
	     (lambda (,b1)
	       (lambda ()
		 (let ((,b3 (,b1
			     ,(type-reference->type-reference-expr
			       (thrift:make-type-reference
				(thriftc:struct-definition-name struct)
				namespace)))))
		   (apply ,b3 (map thrift:field-descriptor-default 
				   (list ,@(map generate-field-descriptor 
						fields))))))))
	    (sealed #t))
	  
	  ,@(let loop ((fields fields)
		       (bindings (list)))
	      (if (null? fields)
		  bindings
		  (let ((f (car fields)))
		    (loop (cdr fields)
			  (append 
			   (list (generate-field-mutator struct f)
				 (generate-field-has-predicate struct f)
				 (generate-field-clear struct f))
			   bindings)))))
	  
	  (define (,(builder-build-name struct) ,b0)
	    (thrift:struct-builder-build ,b0))))))

  (define (thriftc:generate-service namespace definition naming-context)
    (define service-naming-context
      (thriftc:naming-context-service-naming-context naming-context))
      
    (define service-type-name
      (thriftc:service-naming-context-type-name service-naming-context))
    (define service-constructor-name
      (thriftc:service-naming-context-constructor-name service-naming-context))
    (define service-predicate-name
      (thriftc:service-naming-context-predicate-name service-naming-context))
    (define function-accessor-name
      (thriftc:service-naming-context-function-accessor-name 
       service-naming-context))

    (define (argument-names count)
      (define (range count)
	(define (range-inner count lst)
	  (if (eqv? count 0) 
	      (reverse lst) 
	      (range-inner (- count 1) (cons (- count 1) lst))))
	(range-inner count '()))
      (map (lambda (arg-num) 
	     (string->symbol (string-append "a" (number->string arg-num))))
	   (range count)))

    (define (generate-function service function)
      (let ((arguments
	     (argument-names 
	      (length (thriftc:function-definition-arguments function)))))

	`(lambda ,arguments
	   (let ((service-type 
		  ,(type-reference->type-reference-expr
		    (thrift:make-type-reference
		     (thriftc:service-definition-name service) namespace))))
		    
	     (thrift:send-message 
	      transport protocol sequence service-type
	      ,(thriftc:function-definition-name function) ,@arguments)
	   
	   ,@(if (not (thriftc:function-definition-oneway? function))
		 `((thrift:receive-message
		    transport protocol sequence service-type
		    ,(thriftc:function-definition-name function)))
		 '())))))

    (define (generate-function-descriptor-expr function)
      `(thrift:make-function-descriptor
	,(thriftc:function-definition-name function)
	,(type-descriptor->type-reference-expr
	  (thrift:type-reference-descriptor
	   (thriftc:function-definition-return-type function)))
	(list ,@(map (lambda (argument)
		       `(thrift:make-field-descriptor
			 ,(thriftc:field-definition-ordinal argument)
			 ,(thriftc:field-definition-name argument)
			 ,(type-descriptor->type-reference-expr
			   (thrift:type-reference-descriptor
			    (thriftc:field-definition-type argument)))
			 #f #f))
		     (thriftc:function-definition-arguments function)))
	(list ,@(map (lambda (type-reference)
		       (type-descriptor->type-reference-expr
			(thrift:type-reference-descriptor type-reference)))
		     (thriftc:function-definition-throws function)))
	,(thriftc:function-definition-oneway? function)))

    (let-values (((s0 s1 s2) (gensym-values 's0 's1 's2)))
      `((thrift:register-service! ,s1)

	(define ,(service-constructor-name definition)
	  (record-constructor
	   (make-record-constructor-descriptor
	    ,(service-type-name definition)
	    ,(and (thriftc:service-definition-parent definition)
		  `(record-constructor-descriptor
		    ,(service-type-name 
		      (thrift:service-descriptor-name 
		       (thrift:type-reference-descriptor 
			(thriftc:service-definition-parent definition))))))
	    (lambda (n)
	      (lambda (transport protocol)
		(let* ((sequence (thrift:make-sequence))
		       (p (n transport protocol sequence ,s1)))
		  (apply p (,s0 transport protocol sequence))))))))

	(define-record-type (,(service-type-name definition)
			     ,s2
			     ,(service-predicate-name definition))
	  (fields ,@(map (lambda (function)
			   (list 'immutable
				 (string->symbol
				  (thriftc:function-definition-name function))
				 (function-accessor-name definition function)))
			 (thriftc:service-definition-functions definition)))
	  ,(if (thriftc:service-definition-parent definition)
	       `(parent-rtd
		 ,(service-type-name
		   (thrift:service-descriptor-name 
		    (thrift:type-reference-descriptor 
		     (thriftc:service-definition-parent definition))))
		 #f #f)
	       '(parent thrift:client))
	  (protocol (lambda (n)
		      (lambda (transport protocol sequence child-descriptor)
			(let ((p (n transport protocol sequence
				    (thrift:inherit-service-descriptor 
				     ,s1 child-descriptor))))
			  (apply p (,s0 transport protocol)))))))
	
	(define (,s0 transport protocol sequence)
	  (list ,@(map (lambda (function)
			 (generate-function definition function))
		       (thriftc:service-definition-functions definition))))
	(define ,s1
	  (thrift:make-service-descriptor
	   ,(thriftc:service-definition-name definition)
	   ,namespace
	   ,(and (thriftc:service-definition-parent definition)
		 (type-descriptor->type-reference-expr 
		  (thrift:type-reference-descriptor
		   (thriftc:service-definition-parent definition))))
	   (list ,@(map generate-function-descriptor-expr
			(thriftc:service-definition-functions 
			 definition))))))))
  
  (define (calc-field-default field naming-context)
    (define enum-naming-context 
      (thriftc:naming-context-enum-naming-context naming-context))
    (define enum-type-name
      (thriftc:enum-naming-context-type-name enum-naming-context))
    (define enum-value-name 
      (thriftc:enum-naming-context-value-name enum-naming-context)) 
    (define (find-enum-value enum value-name)
      (find (lambda (value) 
	      (equal? (thriftc:enum-value-definition-name value) value-name))
	    (thriftc:enum-definition-values enum)))

    (define type-descriptor
      (thrift:type-reference-descriptor 
       (thriftc:field-definition-type field)))
      
    (if (thrift:enum-field-type-descriptor? type-descriptor)
	(let* ((enum (thrift:field-type-descriptor-name type-descriptor))
	       (value (car (thrift:enum-field-type-descriptor-values 
			    type-descriptor))))
	  (list (enum-type-name enum) (enum-value-name enum value)))
	(thriftc:generate-const-value
	 type-descriptor
	 (thrift:field-type-descriptor-default type-descriptor)
	 naming-context)))
)
